R6 Class
Functions
Expression
- https://adv-r.hadley.nz/expressions.html
- Expression: separate out description of the action from the action itself.
- rlang::expr() function captures the structure of the code without evaluating it.
z <- rlang::expr(y <- x * 10)
zy <- x * 10
x <- 4
base::eval(z)
y[1] 40
Abstract Syntax trees (ASTs)
- The leaves of the trees are either symbols or constants.
- Strings and symbols are easily confused, so strings are always surrounded in quotes.
- The branches of the tree are called objects which represent function calls. The first child is the function that gets called, and the second and subsequent are children that are the arguments to that function.
- The depth within the tree is determined by the nesting of function calls. This also determines evaluation order, as evaluation proceeds from deepest-to-shallowest, but not guaranteed because of lazy evaluation.
- infix vs prefix calls:
library(rlang)
library(lobstr)
lobstr::ast(f(x, "y", 1))█─f ├─x ├─“y” └─1
lobstr::ast(f(g(1, 2), h(3, 4, i())))█─f ├─█─g │ ├─1 │ └─2 └─█─h ├─3 ├─4 └─█─i
Missing arguments to a function
- missing() function inside a function can check if an argument’s value comes from the user or from a default
fx <- function(x = 10, y = NULL) {
list(missing(x), is.null(x), x, missing(y), is.null(y), y)
}
str(fx())List of 6 $ : logi TRUE $ : logi FALSE $ : num 10 $ : logi TRUE $ : logi TRUE $ : NULL
str(fx(5))List of 6 $ : logi FALSE $ : logi FALSE $ : num 5 $ : logi TRUE $ : logi TRUE $ : NULL
str(fx(5, 6))List of 6 $ : logi FALSE $ : logi FALSE $ : num 5 $ : logi FALSE $ : logi FALSE $ : num 6
args(fx)function (x = 10, y = NULL) NULL
lapply(list(1, NULL, 2, NULL), function(x = NULL) is.null(x))[[1]] [1] FALSE
[[2]] [1] TRUE
[[3]] [1] FALSE
[[4]] [1] TRUE
sapply(list(1, NULL, 2, NULL), function(x = NULL) is.null(x))[1] FALSE TRUE FALSE TRUE
sapply(list(1, NULL, 2, NULL), function(x) missing(x))[1] FALSE FALSE FALSE FALSE
Capture the current call
- sys.call() captures exactly what the user feeds the function (some of them positional)
- match.call() captures named arguments
f <- function(a = 1, b = 2, c = 3){
list(sys = sys.call(), match = match.call())
}
f(a = 5, 6)$sys f(a = 5, 6)
$match f(a = 5, b = 6)
f <- function(a = 1, b = 2, c =3){
print(match.call())
print(as.list(match.call()))
s <- do.call("sum", as.list(match.call())[-1L])
print(s)
}
f(1, 2, 3)f(a = 1, b = 2, c = 3) [[1]] f
$a [1] 1
$b [1] 2
$c [1] 3
[1] 6
fx <- function(a = 1, b = 2, c = 3, ...){
all_arguments <- c(as.list(environment()), list(...))
print("All arguments including default arguments:")
print(all_arguments)
print("----------------")
print("match.call(): ")
print(match.call())
print("")
print("----------------")
print("match.call() as list:")
print(as.list(match.call()))
print("")
print("----------------")
print("match.call(expand.dots = TRUE) as list:")
print(as.list(match.call(expand.dots = TRUE)))
print("")
print("----------------")
print("list(...):")
print(list(...))
print("----------------")
s <- do.call("sum", as.list(match.call())[-1L])
print(s)
}
value <- 33
fx(a = value, d = 4, f = 5)[1] “All arguments including default arguments:” $a [1] 33
$b [1] 2
$c [1] 3
$d [1] 4
$f [1] 5
[1] “—————-” [1] “match.call():” fx(a = value, d = 4, f = 5) [1] "" [1] “—————-” [1] “match.call() as list:” [[1]] fx
$a value
$d [1] 4
$f [1] 5
[1] "" [1] “—————-” [1] “match.call(expand.dots = TRUE) as list:” [[1]] fx
$a value
$d [1] 4
$f [1] 5
[1] "" [1] “—————-” [1] “list(…):” $d [1] 4
$f [1] 5
[1] “—————-” [1] 42
call() and do.call()
- call() returns a call object with its name and arguments
- do.call() evaluates the call immediately
call("sum", list(1, 2))sum(list(1, 2))
base::eval(call("sum", c(1, 2)))[1] 3
do.call("sum", list(1, 2))[1] 3
R6 Object RR
library(Wu)
library(R6)
library(sloop)
library(epitools)
dt <- data.table(
outcome = sample(c(0,1), 100, replace = TRUE)
, treatment = factor(rep(c("case", "control"), 50), levels = c("case", "control"))
, sex = factor(sample(c("F", "M"), 100, replace = TRUE), levels = c("F", "M"))
)
RR <- R6Class(
"RR"
, list(binary = NA
, groups = NA
, data = NULL
, groups_nlevels = NULL
, tables = NULL
, freqs = NULL
, ors_str = NULL
, oddsratios = NULL
, riskratios = NULL
, fx_or = function(x) epitools::epitab(x, method = "oddsratio", oddsratio = "wald")
, fx_rr = function(x) epitools::epitab(x, method = "riskratio", oddsratio = "wald")
, initialize = function(binary, groups, data) {
self$binary <- binary
self$groups <- groups
vars <- c(binary, groups)
self$data <- data[, ..vars]
self$groups_nlevels <- lapply(groups, function(x) length(levels(self$data[[x]])))
self$tables <- lapply(self$groups, function(x) table(self$data[[x]], self$data[[self$binary]]))
self$freqs <- lapply(self$groups, function(x) Wu::tab_freq(self$binary, x, self$data))
self$ors_str <- Wu::get_ors(self$binary, self$groups, self$data)
self$oddsratios <- lapply(self$tables, self$fx_or)
self$riskratios <- lapply(self$tables, self$fx_rr)
}
))
RR1 <- RR$new(binary = "outcome", groups = c("treatment", "sex"), data = dt)
otype(RR1)[1] “R6”
str(RR1)Classes ‘RR’, ‘R6’
class(RR1$data)[1] “data.table” “data.frame”
RR1$tables[[1]]
0 1
case 21 29 control 27 23
[[2]]
0 1
F 28 24 M 20 28
RR1$freqs[[1]] predictor label level coef.name N n n.0 n.1 n.str rate.0 rate.1 1: treatment case treatmentcase 100 50 21 29 50/100 0.42 0.58 2: treatment control treatmentcontrol 100 50 27 23 50/100 0.54 0.46 rate.str.0 rate.str.1 odds.0 odds.1 odds.str.0 odds.str.1 1: 42.0%(21/50) 58.0%(29/50) 0.7241379 1.3809524 0.72(21/29) 1.38(29/21) 2: 54.0%(27/50) 46.0%(23/50) 1.1739130 0.8518519 1.17(27/23) 0.85(23/27)
[[2]] predictor label level coef.name N n n.0 n.1 n.str rate.0 rate.1 1: sex F sexF 100 52 28 24 52/100 0.5384615 0.4615385 2: sex M sexM 100 48 20 28 48/100 0.4166667 0.5833333 rate.str.0 rate.str.1 odds.0 odds.1 odds.str.0 odds.str.1 1: 53.8%(28/52) 46.2%(24/52) 1.1666667 0.8571429 1.17(28/24) 0.86(24/28) 2: 41.7%(20/48) 58.3%(28/48) 0.7142857 1.4000000 0.71(20/28) 1.40(28/20)
RR1$orsNULL
RR1$groups_levelsNULL
RR1$groups_nlevels[[1]] [1] 2
[[2]] [1] 2
RR1$oddsratios[[1]] [[1]]$tab
0 p0 1 p1 oddsratio lower upper p.value
case 21 0.4375 29 0.5576923 1.0000000 NA NA NA control 27 0.5625 23 0.4423077 0.6168582 0.279854 1.359688 0.3169521
[[1]]$measure [1] “wald”
[[1]]$conf.level [1] 0.95
[[1]]$pvalue [1] “fisher.exact”
[[2]] [[2]]$tab
0 p0 1 p1 oddsratio lower upper p.value
F 28 0.5833333 24 0.4615385 1.000000 NA NA NA M 20 0.4166667 28 0.5384615 1.633333 0.7401447 3.6044 0.2371371
[[2]]$measure [1] “wald”
[[2]]$conf.level [1] 0.95
[[2]]$pvalue [1] “fisher.exact”
RR1$riskratios[[1]] [[1]]$tab
0 p0 1 p1 riskratio lower upper p.value
case 21 0.42 29 0.58 1.0000000 NA NA NA control 27 0.54 23 0.46 0.7931034 0.5413588 1.161915 0.3169521
[[1]]$measure [1] “wald”
[[1]]$conf.level [1] 0.95
[[1]]$pvalue [1] “fisher.exact”
[[2]] [[2]]$tab
0 p0 1 p1 riskratio lower upper p.value
F 28 0.5384615 24 0.4615385 1.000000 NA NA NA M 20 0.4166667 28 0.5833333 1.263889 0.8655207 1.845612 0.2371371
[[2]]$measure [1] “wald”
[[2]]$conf.level [1] 0.95
[[2]]$pvalue [1] “fisher.exact”
=======R6 Object
library(Wu)
library(R6)
library(sloop)
library(epitools)
dt <- data.table(
outcome = sample(c(0,1), 100, replace = TRUE)
, treatment = factor(rep(c("case", "control"), 50), levels = c("case", "control"))
, sex = factor(sample(c("F", "M"), 100, replace = TRUE), levels = c("F", "M"))
)
RR <- R6Class(
"RR"
, list(binary = NA
, groups = NA
, data = NULL
, groups_nlevels = NULL
, tables = NULL
, freqs = NULL
, ors_str = NULL
, oddsratios = NULL
, riskratios = NULL
, fx_or = function(x) epitools::epitab(x, method = "oddsratio", oddsratio = "wald")
, fx_rr = function(x) epitools::epitab(x, method = "riskratio", oddsratio = "wald")
, initialize = function(binary, groups, data) {
self$binary <- binary
self$groups <- groups
vars <- c(binary, groups)
self$data <- data[, ..vars]
self$groups_nlevels <- lapply(groups, function(x) length(levels(self$data[[x]])))
self$tables <- lapply(self$groups, function(x) table(self$data[[x]], self$data[[self$binary]]))
self$freqs <- lapply(self$groups, function(x) Wu::tab_freq(self$binary, x, self$data))
self$ors_str <- Wu::get_ors(self$binary, self$groups, self$data)
self$oddsratios <- lapply(self$tables, self$fx_or)
self$riskratios <- lapply(self$tables, self$fx_rr)
}
))
RR1 <- RR$new(binary = "outcome", groups = c("treatment", "sex"), data = dt)
add_copy_icon <- function(id){
txt <- paste0('<button type=\"button\" onclick=\"selectElementContents( document.getElementById('
, '\''
, id
, '\''
, ') );\">Copy Table</button>')
cat(txt)
}
add_copy_icon("t1")| 0 | p0 | 1 | p1 | oddsratio | lower | upper | p.value | |
|---|---|---|---|---|---|---|---|---|
| F | 23 | 0.4791667 | 25 | 0.4807692 | 1.0000 | NA | NA | NA |
| M | 25 | 0.5208333 | 27 | 0.5192308 | 0.9936 | 0.4530886 | 2.178914 | 1 |
Test GPU (doesn’t work)
- http://www.r-tutor.com/gpu-computing/clustering/distance-matrix
- https://github.com/cdeterman/gpuR/wiki/Build-Instructions-for-Linux
test.data <- function(dim, num, seed = 17){
set.seed(seed)
matrix(rnorm(dim * dim), nrow = num)
}
m <- test.data(1200, 45000)
system.time(dist(m))
# Dev RViennaCL
devtools::install_github("cdeterman/RViennaCL")
# Dev gpuR
devtools::install_github("cdeterman/gpuR")
A <- seq.int(from=0, to=999)
B <- seq.int(from=1000, to=1)
gpuA <- gpuVector(A)
gpuB <- gpuVector(B)
C <- A + B
gpuC <- gpuA + gpuB
all(C == gpuC)Environment
R version 4.1.0 (2021-05-18) Platform: x86_64-pc-linux-gnu (64-bit) Running under: Ubuntu 20.04.2 LTS
Matrix products: default BLAS: /usr/lib/x86_64-linux-gnu/blas/libblas.so.3.9.0 LAPACK: /usr/lib/x86_64-linux-gnu/lapack/liblapack.so.3.9.0
locale: [1] LC_CTYPE=C.UTF-8 LC_NUMERIC=C LC_TIME=C.UTF-8
[4] LC_COLLATE=C.UTF-8 LC_MONETARY=C.UTF-8 LC_MESSAGES=C.UTF-8
[7] LC_PAPER=C.UTF-8 LC_NAME=C LC_ADDRESS=C
[10] LC_TELEPHONE=C LC_MEASUREMENT=C.UTF-8 LC_IDENTIFICATION=C
attached base packages: [1] stats graphics grDevices utils datasets methods base
other attached packages: [1] epitools_0.5-10.1 sloop_1.0.1 R6_2.5.0
[4] Wu_0.0.0.9000 flexdashboard_0.5.2 lme4_1.1-27.1
[7] Matrix_1.3-4 mgcv_1.8-36 nlme_3.1-152
[10] png_0.1-7 scales_1.1.1 nnet_7.3-16
[13] labelled_2.8.0 kableExtra_1.3.4 plotly_4.9.4.1
[16] gridExtra_2.3 ggplot2_3.3.5 DT_0.18
[19] tableone_0.13.0 magrittr_2.0.1 lubridate_1.7.10
[22] dplyr_1.0.7 plyr_1.8.6 data.table_1.14.0
[25] rmdformats_1.0.2 knitr_1.33
loaded via a namespace (and not attached): [1] httr_1.4.2 sass_0.4.0 tidyr_1.1.3 jsonlite_1.7.2
[5] viridisLite_0.4.0 splines_4.1.0 bslib_0.2.5.1 assertthat_0.2.1 [9] highr_0.9 yaml_2.2.1 pillar_1.6.1 lattice_0.20-44
[13] glue_1.4.2 digest_0.6.27 rvest_1.0.0 minqa_1.2.4
[17] colorspace_2.0-2 htmltools_0.5.1.1 survey_4.0 pkgconfig_2.0.3
[21] haven_2.4.1 bookdown_0.22 purrr_0.3.4 webshot_0.5.2
[25] svglite_2.0.0 tibble_3.1.2 generics_0.1.0 ellipsis_0.3.2
[29] withr_2.4.2 klippy_0.0.0.9500 lazyeval_0.2.2 survival_3.2-11
[33] crayon_1.4.1 evaluate_0.14 fansi_0.5.0 MASS_7.3-54
[37] forcats_0.5.1 xml2_1.3.2 tools_4.1.0 hms_1.1.0
[41] mitools_2.4 lifecycle_1.0.0 stringr_1.4.0 munsell_0.5.0
[45] compiler_4.1.0 jquerylib_0.1.4 systemfonts_1.0.2 rlang_0.4.11
[49] grid_4.1.0 nloptr_1.2.2.2 rstudioapi_0.13 htmlwidgets_1.5.3 [53] crosstalk_1.1.1 rmarkdown_2.9 boot_1.3-28 gtable_0.3.0
[57] DBI_1.1.1 performance_0.7.2 utf8_1.2.1 insight_0.14.2
[61] stringi_1.6.2 Rcpp_1.0.7 vctrs_0.3.8 tidyselect_1.1.1 [65] xfun_0.24